home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / FORTH / FORTHMAC / OLD / TOOLS1 / !Forthmacs.extend.stackcheck < prev    next >
Text File  |  1996-06-12  |  1KB  |  55 lines
  1. \ Automatic checker for stack integrity.
  2. \ Use as:  
  3. \   : name  (s param -- param2 param3 param4 )
  4. \       ...
  5. \   ;
  6. \ The (s counts parameters in the stack comment, and checks at run
  7. \ time for the proper change in stack depth between the start of
  8. \ the word and the end.  Params must be separated by spaces.
  9. \ '--' and ')' must be spelled as shown and separated by spaces.
  10. \
  11. \ This feature is enabled or disabled with:
  12. \     stackcheck on  -or-  stackcheck off
  13. \
  14. \ Default value is OFF
  15.  
  16. variable stackcheck  stackcheck off
  17.  
  18. : check-stack    ( -- )    ( rs: next-acf expected-depth bogus-acf -- )
  19.     r> drop depth r> =
  20.     if    ['] ;   compile,
  21.     else    error-output ??cr
  22.         rp0 @  rp@  [ also hidden ] (rstrace [ previous ]
  23.         restore-output d# -334 throw
  24.     then ;
  25. variable checker    \ Dummy variable, to hold acf of check-stack
  26. ' check-stack checker !
  27.  
  28. : pcomp        ( pstr1 pstr2 -- n )    \ 0 if the same
  29.     count  rot count  ( addr2 len2 addr1 len1 )
  30.     rot max  comp ;
  31.  
  32. : read-stack  ( -- +-depth )
  33.     0
  34.     begin    blword  p" --"  pcomp
  35.     while    1-
  36.     repeat
  37.     begin    blword  p" )"   pcomp
  38.     while  1+
  39.     repeat ;
  40.  
  41. alias old-(s  (s
  42.  
  43. \ At compile time, count stack items in the comment for expected offset
  44. \ At run time, push current-depth +-offset onto rs:, then push check-acf
  45. : (s    \ stack-in -- stack-out )  ( -- )
  46.     ( rs: -- proper-depth check-acf )
  47.     stackcheck @
  48.     if    postpone depth
  49.         read-stack do-literal
  50.         postpone +  postpone >r
  51.         checker  do-literal  postpone >r
  52.     else    postpone old-(s
  53.     then ; immediate
  54.  
  55.